home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / state.c < prev    next >
C/C++ Source or Header  |  1993-03-25  |  7KB  |  280 lines
  1. /* ******************************************************************** */
  2. /* state.c           Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Lisp state                                                   */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: state.c,v 1.8 1992/11/26 16:05:43 pab Exp $
  9.  *
  10.  * $Log: state.c,v $
  11.  * Revision 1.8  1992/11/26  16:05:43  pab
  12.  * Lost Envs
  13.  *
  14.  * Revision 1.7  1992/07/13  13:15:56  djb
  15.  * ifdef DGC (compacting mark+sweep collector)
  16.  * then zero unused portions of c and gc-stack
  17.  * before gc (tidy_stacks())
  18.  *
  19.  * Revision 1.6  1992/01/29  13:48:20  pab
  20.  * additional debug info for sysV
  21.  *
  22.  * Revision 1.5  1992/01/05  22:48:22  pab
  23.  * Minor bug fixes, plus BSD version
  24.  *
  25.  * Revision 1.4  1991/12/22  15:14:35  pab
  26.  * Xmas revision
  27.  *
  28.  * Revision 1.3  1991/11/15  13:45:35  pab
  29.  * copyalloc rev 0.01
  30.  *
  31.  * Revision 1.2  1991/09/11  12:07:42  pab
  32.  * 11/9/91 First Alpha release of modified system
  33.  *
  34.  * Revision 1.1  1991/08/12  16:50:01  pab
  35.  * Initial revision
  36.  *
  37.  * Revision 1.6  1991/02/13  18:25:07  kjp
  38.  * Pass.
  39.  *
  40.  */
  41.  
  42. /*
  43.  * Change Log:
  44.  *   Version 1, May 1990
  45.  */
  46.  
  47. /*
  48.  
  49.  * This holds the "state" data and operations - should be system
  50.  * independant and encapsulte ALL continuation operations...
  51.  
  52.  */
  53.  
  54. #include "funcalls.h"
  55. #include "defs.h"
  56. #include "structs.h"
  57. #include "error.h"
  58. #include "global.h"
  59.  
  60. #include "calls.h"
  61. #include "modboot.h"
  62. #include "allocate.h"
  63. #include "modules.h"
  64. #include "threads.h"
  65.  
  66. #include "state.h"
  67.  
  68. /* Fixed outside of a context switch... */
  69.  
  70. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_current_thread);
  71. SYSTEM_THREAD_SPECIFIC_DECLARATION(int*,state_stack_base);
  72. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject*,state_gc_stack_base);
  73.  
  74. /* Forever wandering... */
  75.  
  76. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject*,state_gc_stack_pointer);
  77. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_dynamic_env);
  78. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_last_continue);
  79. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_handler_stack);
  80.  
  81. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,dp);
  82. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,dlp);
  83.  
  84. /* Notionally, the registers hold the machine state */
  85.  
  86. /*
  87.  * Loads the lisp specific state of the world into a continuation struct
  88.  */
  89.  
  90. LispObject save_state(LispObject *stacktop,LispObject cont)
  91. {
  92. #ifndef NODEBUG
  93.   extern int gc_paranoia;
  94.  
  95.   if (gc_paranoia)
  96.     fprintf(stderr,"{Save: 0x%x->0x%x[%d]}",
  97.         SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_base),
  98.         stacktop,(stacktop-SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_base))/sizeof(LispObject));
  99. #endif
  100.   cont->CONTINUE.gc_stack_pointer 
  101.     = stacktop;
  102.  
  103.   cont->CONTINUE.dynamic_env
  104.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_dynamic_env);
  105.  
  106.   cont->CONTINUE.last_continue
  107.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue);
  108.  
  109.   cont->CONTINUE.handler_stack
  110.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_handler_stack);
  111.  
  112.   cont->CONTINUE.dp 
  113.     = SYSTEM_THREAD_SPECIFIC_VALUE(dp);
  114.  
  115.   return(cont);
  116.  
  117. }
  118.  
  119. /*
  120.  * Similarly, the other way around...
  121.  */
  122.  
  123. void change_state(LispObject cont)
  124. {
  125.   
  126.   SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_pointer)
  127.     = cont->CONTINUE.gc_stack_pointer;
  128.  
  129.   SYSTEM_THREAD_SPECIFIC_VALUE(state_dynamic_env)
  130.     = cont->CONTINUE.dynamic_env;
  131.  
  132.   SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue)
  133.     = cont->CONTINUE.last_continue;
  134.  
  135.   SYSTEM_THREAD_SPECIFIC_VALUE(state_handler_stack)
  136.     = cont->CONTINUE.handler_stack;
  137.  
  138.   SYSTEM_THREAD_SPECIFIC_VALUE(dp)
  139.     = cont->CONTINUE.dp;
  140.  
  141.   SYSTEM_THREAD_SPECIFIC_VALUE(dlp)
  142.     = cont->CONTINUE.dp;
  143. }
  144.  
  145. /*
  146.  
  147.  * Set a continuation...
  148.  *
  149.  * Note: these are just the lisp equivalents of setjmp and longjmp -
  150.  *       they do not deal with killing other continuations apart from
  151.  *       themselves or handling unwind protects.
  152.  
  153.  * Note also that all this hackery is required to provide abstraction
  154.  * 'cos were it a standard function call, the stack would get nobbled.
  155.  
  156.  */
  157.  
  158. int set_continue_1(LispObject *stacktop,LispObject cont)
  159. {
  160.  
  161.   cont->CONTINUE.thread = SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread);
  162.  
  163.   save_state(stacktop,cont);
  164.  
  165.   cont->CONTINUE.value = nil;
  166.  
  167.   return(TRUE);
  168.  
  169. }
  170.  
  171. int set_continue_2(LispObject cont)
  172. {
  173.  
  174.   /* Fix last continue... */
  175.  
  176.   LAST_CONTINUE() = cont;
  177.  
  178.   /* All set... */
  179.  
  180.   cont->CONTINUE.live = TRUE;
  181.  
  182.   return(FALSE);
  183.  
  184. }
  185.  
  186. void call_continue(LispObject *stacktop,LispObject cont,LispObject value)
  187. {
  188.   
  189.   if (!is_continue(cont)) {
  190.     printf("****BAD CONTINUATION**** type %d - waiting...\n",typeof(cont));
  191.     fflush(stdout);
  192.     exit(1);
  193.   }
  194.  
  195.   if (cont->CONTINUE.thread 
  196.       != SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread))
  197.     {    
  198.       fprintf(stderr,"Wrong thread: %x[%d] %x[%d]\n",SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread),
  199.           SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread)->THREAD.header.gc,
  200.           cont->CONTINUE.thread,cont->CONTINUE.thread->THREAD.header.gc);
  201.       CallError(stacktop,"call continuation: wrong thread",cont,NONCONTINUABLE);
  202.     }
  203.  
  204.   cont->CONTINUE.live = FALSE;
  205.  
  206.   /* Already on current thread... */
  207.  
  208.   change_state(cont);
  209.  
  210.   cont->CONTINUE.value = value;
  211.  
  212.  
  213.   longjmp(cont->CONTINUE.machine_state,TRUE);
  214.  
  215. }
  216.  
  217. #ifdef DGC
  218.  
  219. /* clear unused areas of c-stack and gc-stack so that c-gc will 
  220.    collect objects that were pointed to from within those areas */
  221.  
  222. void tidy_stacks(LispObject *stacktop)
  223. {
  224.   int *ptr;
  225.  
  226.   if (stacktop!=NULL)
  227.   {
  228. #ifndef NODEBUG
  229.     fprintf(stderr,"stacktop=%p, gc_stack_base=%p, gc_stack_size=%p\n",
  230.         stacktop,thread_gc_stack_base(CURRENT_THREAD()),
  231.         thread_gc_stack_size(CURRENT_THREAD())); 
  232.  
  233.     fprintf(stderr,"clearing %p of gc-stack\n",
  234.         thread_gc_stack_base((CURRENT_THREAD()))+
  235.         thread_gc_stack_size(CURRENT_THREAD()-stacktop));
  236. #endif
  237.     for (ptr=(int *)(thread_gc_stack_base(CURRENT_THREAD()) + 
  238.              thread_gc_stack_size(CURRENT_THREAD())); 
  239.      ptr>(int *)stacktop; 
  240.      ptr--)
  241.       *ptr=NULL;
  242.   }  
  243. #ifndef NODEBUG
  244.   fprintf(stderr,"stack_base=%p, &ptr=%p\n",
  245.       (int *)(thread_stack_base(CURRENT_THREAD())), &ptr);
  246.  
  247.   fprintf(stderr,"clearing %p of c-stack out of %p\n",
  248.       (int *)&ptr - (int *)(thread_stack_base(CURRENT_THREAD())),
  249.       (int *)(thread_stack_size(CURRENT_THREAD())));
  250. #endif
  251.   for (ptr=(int *)(thread_stack_base(CURRENT_THREAD()));
  252.        ptr<(int *)&ptr; /* an arbitrary local variable */
  253.        ptr++)
  254.     *ptr=NULL;
  255.   }
  256. #endif
  257.  
  258. /*
  259.  
  260.  * Load a thread into the system ready for execution...
  261.  
  262.  * returns the new GC stacktop
  263.  */
  264.  
  265. LispObject* load_thread(LispObject thread)
  266. {
  267.  
  268.   CURRENT_THREAD() = thread;
  269.  
  270.   STACK_BASE()    = thread_stack_base(thread);
  271.   GC_STACK_BASE() = thread_gc_stack_base(thread);
  272.   
  273.   /* Just the flexible stuff left... */
  274.  
  275.   change_state(thread->THREAD.state);
  276.  
  277.   return (thread->THREAD.state->CONTINUE.gc_stack_pointer);
  278. }
  279.  
  280.